perm filename FEYN[900,BGB] blob
sn#129590 filedate 1974-11-11 generic text, type T, neo UTF8
00100 (DEFPROP WWW
00200 (NIL PFEY
00300 DFEY
00400 FEYNMAN
00500 OVERLAP
00600 EQVAL
00700 PHUNT
00800 SETLEVEL
00900 OUTPART
01000 TAGEL
01100 TORG
01200 TORG2
01300 ARROW
01400 FERMI1
01500 BOSE1
01600 BOSE2
01700 FERMI2
01800 FERMI3
01900 ZEG
02000 JIGJAG
02100 JIGJAGZIGZAG
02200 NSET
02300 TFSET
02400 NILVAL
02500 FUSE
02600 IOBOTH
02700 DELETE
02800 INSERT
02900 UNIQUE
03000 UNBUCK
03100 SUBSET
03200 INTERSECTION
03300 PEN
03400 ORG
03500 SIZORG
03600 SIZ
03700 KING
03800 GETNEAR
03900 PNSET
04000 XPLY
04100 ALIKE
04200 SETN
04300 XSET
04400 YSET
04500 YSET2
04600 OAOOP
04700 MOVE
04800 YMINAX
04900 YMISS
05000 LSP
05100 MIDIT
05200 DIT
05300 SOF
05400 EOF
05500 POT
05600 YMAX
05700 XMAX
05800 YMIN
05900 F1
06000 F2
06100 NK
06200 NP
06300 NODE
06400 N0
06500 N1
06600 N2
06700 N3
06800 N4
06900 N5
07000 N6
07100 N7
07200 N8
07300 N9
07400 VADD
07500 VSUB
07600 VSUBSIZ
07700 LXY
07800 SLOPE
07900 MIDPOINT
08000 METRIC
08100 SQUARE
08200 INCREM
08300 CARLAST
08400 ALSH
08500 ADJUST
08600 ROTATE
08700 ROOT
08800 NEWTON
08900 ZIGZAG
09000 SQUIG
09100 TESTS
09200 TP1
09300 TP2
09400 TP3
09500 TP4
09600 TP5
09700 TP6
09800 TP7
09900 TP8
10000 TP9
10100 TP10
10200 TP11
10300 TP12
10400 TP13
10500 TP14
10600 TP15
10700 TP16
10800 TP17
10900 TP18
11000 TP19
11100 TP20
11200 TP20
11300 TP22
11400 OFF)
11500 VALUE)
11600
11700 (DEFPROP PFEY
11800 (LAMBDA(Z)
11900 (PROG (IPL OPL MPL EPL INL ONL MNL ENL YMAX YMIN XMAX)
12000 (SETQ YMAX (SETQ YMIN (SETQ XMAX 0)))
12100 (FEYNMAN Z)
12200 (MAPC (FUNCTION ADJUST) ENL)
12300 (OVERLAP EPL)
12400 (LSP (LIST 0 (TIMES 300 (MINUS YMIN))))
12500 (SETQ ORG (QUOTE (0 . 0)))
12600 (OUTPART (FUNCTION LSP) EPL)
12700 (LSP (LIST (MINUS (CAR (SIZORG))) (PLUS (TIMES 300 YMAX) (MINUS (CDR (SIZORG))) 220)))))
12800 EXPR)
12900
13000 (DEFPROP FEYNMAN
13100 (LAMBDA(Z)
13200 (PROG (NOL)
13300 (CSYM G0000)
13400 (MAPC (FUNCTION NILVAL) (APPEND (CAAR (FUSE Z)) (CDAR (FUSE Z))))
13500 (SETQ MNL (NSET Z))
13600 (SETQ EPL (IOBOTH (FUSE Z)))
13700 (SETQ IPL (CAAR EPL))
13800 (SETQ OPL (CDAR EPL))
13900 (SETQ MPL (CDR EPL))
14000 (SETQ EPL (APPEND IPL OPL MPL))
14100 (SETQ INL (NSET (MAPCAR (FUNCTION (LAMBDA (Z) (LIST NIL Z))) IPL)))
14200 (SETQ ONL (NSET (MAPCAR (FUNCTION (LAMBDA (Z) (LIST (LIST Z)))) OPL)))
14300 (SETQ ENL (APPEND INL MNL ONL))
14400 (MAPC (FUNCTION KING) ENL)
14500 (MAPC (FUNCTION PNSET) ENL)
14600 (XPLY 0 INL NIL)
14700 (SETQ NOL ENL)
14800 YLOOP
14900 (YSET (CAR NOL) YMIN)
15000 (SETQ NOL (YMISS ENL))
15100 (YMINAX (SUBSET ENL NOL))
15200 (COND ((NOT (NULL NOL)) (GO YLOOP)))
15300 (XSET ONL XMAX)
15400 (RETURN NIL)))
15500 EXPR)
15600
15700 (DEFPROP OVERLAP
15800 (LAMBDA(Z)
15900 (COND ((NULL Z) NIL)
16000 ((AND (NOT (MEMBER (EVAL (CAR Z)) (MAPCAR (FUNCTION EVAL) (CDR Z))))
16100 (NOT (MEMBER (CONS (CDR (EVAL (CAR Z))) (CAR (EVAL (CAR Z)))) (MAPCAR (FUNCTION EVAL) (CDR Z)))))
16200 (PROG2 (SET (CAR Z) (CONS (EVAL (CAR Z)) 0)) (OVERLAP (CDR Z))))
16300 (T
16400 (PROG (IDPL)
16500 (SETQ IDPL (EQVAL (EVAL (CAR Z)) Z))
16600 (SETLEVEL 0 (PHUNT IDPL IDPL))
16700 (OVERLAP (SUBSET Z IDPL))))))
16800 EXPR)
16900
17000 (DEFPROP EQVAL
17100 (LAMBDA(A Z)
17200 (COND ((NULL Z) NIL)
17300 ((OR (EQUAL A (CONS (CDR (EVAL (CAR Z))) (CAR (EVAL (CAR Z))))) (EQUAL A (EVAL (CAR Z))))
17400 (CONS (CAR Z) (EQVAL A (CDR Z))))
17500 (T (EQVAL A (CDR Z)))))
17600 EXPR)
17700
17800 (DEFPROP PHUNT
17900 (LAMBDA(Z1 Z2)
18000 (COND ((NULL Z2) Z1)
18100 ((EQ (QUOTE P) (CAR (EXPLODE (CAR Z2)))) (CONS (CAR Z2) (DELETE (CAR Z2) Z1)))
18200 (T (PHUNT Z1 (CDR Z2)))))
18300 EXPR)
18400
18500 (DEFPROP SETLEVEL
18600 (LAMBDA(N Z)
18700 (COND ((NULL Z) NIL)
18800 (T
18900 (PROG2 (SET (CAR Z) (CONS (EVAL (CAR Z)) N))
19000 (SETLEVEL (COND ((ZEROP N) 1) ((MINUSP N) (MINUS (SUB1 N))) (T (MINUS N))) (CDR Z))))))
19100 EXPR)
19200
19300 (DEFPROP OUTPART
19400 (LAMBDA(LS Z)
19500 (COND ((NULL Z) NIL)
19600 (T
19700 (PROG (PPP1 PPP2 LEVEL MIDP CC SS LL L2 KIND)
19800 (SETQ LEVEL (CDR (EVAL (CAR Z))))
19900 (SETQ PPP1 (EVAL (CAAR (EVAL (CAR Z)))))
20000 (SETQ PPP2 (EVAL (CDAR (EVAL (CAR Z)))))
20100 (SETQ KIND (EQ (QUOTE P) (CAR (EXPLODE (CAR Z)))))
20200 (COND
20300 ((EQUAL PPP1 PPP2)
20400 (PROG2 (SETQ LEVEL 1)
20500 (COND (KIND (FERMI3 (FUNCTION JIGJAG))) (T (FERMI3 (FUNCTION JIGJAGZIGZAG))))
20600 (RETURN (OUTPART LS (CDR Z))))))
20700 (SETQ MIDP (MIDPOINT PPP1 PPP2))
20800 (LS (LXY (VSUB PPP1 (SIZORG))))
20900 (SETQ L2 (METRIC PPP1 PPP2))
21000 (SETQ LL (ROOT L2))
21100 (SETQ SS (QUOTIENT (DIFFERENCE (CDR PPP2) (CDR PPP1)) LL))
21200 (SETQ CC (QUOTIENT (DIFFERENCE (CAR PPP2) (CAR PPP1)) LL))
21300 (COND ((GET (CAR Z) (QUOTE NFROM)) (MAPC LS NODE)))
21400 (COND ((AND (ZEROP LEVEL) KIND) (FERMI1)) ((ZEROP LEVEL) (BOSE1)) (KIND (FERMI2)) (T (BOSE2)))
21500 (COND ((GET (CAR Z) (QUOTE NTO)) (MAPC LS NODE)))
21600 (OUTPART LS (CDR Z))))))
21700 EXPR)
21800
21900 (DEFPROP TAGEL
22000 (LAMBDA(S C LS CHARS)
22100 (LS
22200 (LXY
22300 (VSUBSIZ ORG
22400 (PROG2 (LS (LXY (VADD (ROTATE (TORG) S C) (TORG2))))
22500 (CARLAST
22600 (MAPCAR (FUNCTION
22700 (LAMBDA (Z) (CARLAST (MAPCAR LS (EVAL (INTERN (MAKNAM (LIST (QUOTE N) Z))))))))
22800 CHARS)))))))
22900 EXPR)
23000
23100 (DEFPROP TORG
23200 (LAMBDA NIL
23300 (CONS
23400 (COND
23500 ((OR (MINUSP C) (AND (OR (GREATERP C S) (EQ C S)) (GREATERP S (MINUS C))) (AND (ZEROP C) (MINUSP S))) -6)
23600 (T 6))
23700 (COND
23800 ((OR (AND (MINUSP S) (GREATERP C S)) (AND (NOT (MINUSP S)) (GREATERP (MINUS C) S)) (ZEROP S)) 11)
23900 (T -11))))
24000 EXPR)
24100
24200 (DEFPROP TORG2
24300 (LAMBDA NIL
24400 (CONS
24500 (COND
24600 ((OR (AND (GREATERP S C) (GREATERP (MINUS C) S)) (AND (EQUAL S C) (MINUSP S))) (TIMES -14 (LENGTH CHARS)))
24700 (T 0))
24800 (COND
24900 ((OR (AND (GREATERP C 0) (GREATERP S 0))
25000 (AND (GREATERP C S) (MINUSP C))
25100 (AND (GREATERP (MINUS C) S) (NOT (MINUSP S)))
25200 (ZEROP C))
25300 -14)
25400 (T 0))))
25500 EXPR)
25600
25700 (DEFPROP ARROW
25800 (LAMBDA(S C LS)
25900 (PROG (PSORG)
26000 (SETQ PSORG ORG)
26100 (LS (ROTATE (QUOTE (-25 . 25)) S C))
26200 (LS (ROTATE (QUOTE (17 . -25)) S C))
26300 (LS (ROTATE (QUOTE (-17 . -25)) S C))
26400 (LS
26500 (CONS (QUOTIENT (DIFFERENCE (CAR PSORG) (CAR ORG)) SIZ)
26600 (QUOTIENT (DIFFERENCE (CDR PSORG) (CDR ORG)) SIZ)))))
26700 EXPR)
26800
26900 (DEFPROP FERMI1
27000 (LAMBDA NIL
27100 (PROG NIL (LS (VSUB MIDP PPP1)) (ARROW SS CC LS) (TAGEL SS CC LS (EXPLODE (CAR Z))) (LS (VSUB PPP2 MIDP))))
27200 EXPR)
27300
27400 (DEFPROP BOSE1
27500 (LAMBDA NIL
27600 (PROG (PHASE ACTEND)
27700 (SETQ PHASE 0)
27800 (SETQ ACTEND (QUOTE (0 . 0)))
27900 (SQUIG PPP1 MIDP LS)
28000 (ZEG)
28100 (ARROW SS CC LS)
28200 (TAGEL SS CC LS (EXPLODE (CAR Z)))
28300 (SQUIG MIDP PPP2 LS)
28400 (ZEG)))
28500 EXPR)
28600
28700 (DEFPROP BOSE2
28800 (LAMBDA NIL
28900 (PROG (PSORG LLX PHASE ACTEND)
29000 (SETQ PSORG (SETQ ACTEND (QUOTE (0 . 0))))
29100 (SETQ PHASE 0)
29200 (SETQ LLX (QUOTIENT (ROOT (METRIC PPP2 PPP1)) 8.0))
29300 (JIGJAGZIGZAG 1 (QUOTE (36 52 60 60)))
29400 (ZEG)
29500 (ARROW SS CC LS)
29600 (TAGEL SS CC LS (EXPLODE (CAR Z)))
29700 (JIGJAGZIGZAG 5 (QUOTE (60 52 36 0)))
29800 (ZEG)))
29900 EXPR)
30000
30100 (DEFPROP FERMI2
30200 (LAMBDA NIL
30300 (PROG (PSORG LLX)
30400 (SETQ PSORG (QUOTE (0 . 0)))
30500 (SETQ LLX (QUOTIENT (ROOT (METRIC PPP2 PPP1)) 8.0))
30600 (JIGJAG 1 (QUOTE (36 52 60 60)))
30700 (ARROW SS CC LS)
30800 (TAGEL SS CC LS (EXPLODE (CAR Z)))
30900 (JIGJAG 5 (QUOTE (60 52 36)))
31000 (LS (VSUB PPP2 (SIZORG)))))
31100 EXPR)
31200
31300 (DEFPROP FERMI3
31400 (LAMBDA(JIGGLE)
31500 (PROG (PSORG LLX PHASE ACTEND)
31600 (COND ((OR (GET (CAR Z) (QUOTE NTO)) (GET (CAR Z) (QUOTE NFROM))) (MAPC LS NODE)))
31700 (SETQ PSORG (SETQ ACTEND (QUOTE (0 . 0))))
31800 (SETQ PHASE 0)
31900 (SETQ LLX (TIMES SIZ -30))
32000 (SETQ SS 0.0)
32100 (SETQ CC 1.0)
32200 (JIGGLE 1 (QUOTE (11 36)))
32300 (SETQ LLX (MINUS LLX))
32400 (JIGGLE -1 (QUOTE (60 60)))
32500 (ARROW SS CC LS)
32600 (TAGEL SS CC LS (EXPLODE (CAR Z)))
32700 (JIGGLE 0 (QUOTE (60 60 36)))
32800 (SETQ LLX (MINUS LLX))
32900 (JIGGLE -1 (QUOTE (11)))
33000 (JIGGLE 0 (QUOTE (0)))))
33100 EXPR)
33200
33300 (DEFPROP ZEG
33400 (LAMBDA NIL (PROG2 (LS (CONS (MINUS (CAR ACTEND)) (MINUS (CDR ACTEND)))) (SETQ ACTEND (QUOTE (0 . 0)))))
33500 EXPR)
33600
33700 (DEFPROP JIGJAG
33800 (LAMBDA(N Z)
33900 (COND ((NULL Z) NIL)
34000 (T
34100 (PROG (PTEMP)
34200 (SETQ PTEMP (ROTATE (CONS (TIMES N LLX) (TIMES LEVEL (CAR Z))) SS CC))
34300 (LS (VSUB PTEMP PSORG))
34400 (SETQ PSORG PTEMP)
34500 (JIGJAG (ADD1 N) (CDR Z))))))
34600 EXPR)
34700
34800 (DEFPROP JIGJAGZIGZAG
34900 (LAMBDA(N Z)
35000 (COND ((NULL Z) NIL)
35100 (T
35200 (PROG (PTEMP)
35300 (SETQ PTEMP (ROTATE (CONS (TIMES N LLX) (TIMES LEVEL (CAR Z))) SS CC))
35400 (SQUIG PSORG PTEMP LS)
35500 (SETQ PSORG PTEMP)
35600 (JIGJAGZIGZAG (ADD1 N) (CDR Z))))))
35700 EXPR)
35800
35900 (DEFPROP NSET
36000 (LAMBDA(Z)
36100 (COND ((NULL Z) NIL)
36200 (T
36300 (CONS (PROG (TEMP)
36400 (SET (SETQ TEMP (INTERN (GENSYM))) (CAR Z))
36500 (TFSET (CAAR Z) (FUNCTION CONS))
36600 (TFSET (CDAR Z) (FUNCTION XCONS))
36700 (RETURN TEMP))
36800 (NSET (CDR Z))))))
36900 EXPR)
37000
37100 (DEFPROP TFSET
37200 (LAMBDA(Z FCONS)
37300 (MAPC (FUNCTION
37400 (LAMBDA(X)
37500 (SET X
37600 (COND ((NULL (EVAL X)) (FCONS NIL TEMP))
37700 (T (FCONS (CAR (FCONS (CAR (EVAL X)) (CDR (EVAL X)))) TEMP))))))
37800 Z))
37900 EXPR)
38000
38100 (DEFPROP NILVAL
38200 (LAMBDA (Z) (SET Z NIL))
38300 EXPR)
38400
38500 (DEFPROP FUSE
38600 (LAMBDA(Z)
38700 (COND ((NULL Z) NIL)
38800 ((NULL (CDR Z)) Z)
38900 (T (FUSE (CONS (CONS (APPEND (CAAR Z) (CAADR Z)) (APPEND (CDAR Z) (CDADR Z))) (CDDR Z))))))
39000 EXPR)
39100
39200 (DEFPROP IOBOTH
39300 (LAMBDA(Z)
39400 (COND ((NULL (CAAR Z)) Z)
39500 ((NULL (CDAR Z)) Z)
39600 ((MEMBER (CAAAR Z) (CDAR Z))
39700 (IOBOTH
39800 (CONS (CONS (DELETE (CAAAR Z) (CDAAR Z)) (DELETE (CAAAR Z) (CDAR Z))) (CONS (CAAAR Z) (CDR Z)))))
39900 (T (INSERT (CAAAR Z) (IOBOTH (CONS (CONS (DELETE (CAAAR Z) (CDAAR Z)) (CDAR Z)) (CDR Z)))))))
40000 EXPR)
40100
40200 (DEFPROP DELETE
40300 (LAMBDA(A Z)
40400 (COND ((NULL Z) NIL) (T (APPEND (COND ((EQ A (CAR Z)) NIL) (T (NCONS (CAR Z)))) (DELETE A (CDR Z))))))
40500 EXPR)
40600
40700 (DEFPROP INSERT
40800 (LAMBDA (A Z) (CONS (CONS (CONS A (CAAR Z)) (CDAR Z)) (CDR Z)))
40900 EXPR)
41000
41100 (DEFPROP UNIQUE
41200 (LAMBDA (Z) (COND ((NULL Z) NIL) (T (CONS (CAR Z) (DELETE (CAR Z) (UNIQUE (CDR Z)))))))
41300 EXPR)
41400
41500 (DEFPROP UNBUCK
41600 (LAMBDA (Z) (COND ((NULL Z) NIL) (T (APPEND (CAR Z) (UNBUCK (CDR Z))))))
41700 EXPR)
41800
41900 (DEFPROP SUBSET
42000 (LAMBDA (A B) (COND ((NULL B) A) (T (SUBSET (DELETE (CAR B) A) (CDR B)))))
42100 EXPR)
42200
42300 (DEFPROP INTERSECTION
42400 (LAMBDA(A B)
42500 (COND ((OR (NULL A) (NULL B)) NIL)
42600 (T (APPEND (COND ((MEMQ (CAR A) B) (NCONS (CAR A))) (T NIL)) (INTERSECTION (CDR A) B)))))
42700 EXPR)
42800
42900 (DEFPROP PEN
43000 (NIL)
43100 VALUE)
43200
43300 (DEFPROP ORG
43400 (NIL 0 . 220)
43500 VALUE)
43600
43700 (DEFPROP SIZORG
43800 (LAMBDA NIL (CONS (QUOTIENT (CAR ORG) SIZ) (QUOTIENT (CDR ORG) SIZ)))
43900 EXPR)
44000
44100 (DEFPROP SIZ
44200 (NIL . 1)
44300 VALUE)
44400
44500 (DEFPROP KING
44600 (LAMBDA(Z)
44700 (PUTPROP Z
44800 (UNIQUE
44900 (APPEND (MAPCAR (FUNCTION CAR) (MAPCAR (FUNCTION EVAL) (CAR (EVAL Z))))
45000 (MAPCAR (FUNCTION CDR) (MAPCAR (FUNCTION EVAL) (CDR (EVAL Z))))))
45100 (QUOTE NEAR)))
45200 EXPR)
45300
45400 (DEFPROP GETNEAR
45500 (LAMBDA (Z) (GET Z (QUOTE NEAR)))
45600 EXPR)
45700
45800 (DEFPROP PNSET
45900 (LAMBDA(Z)
46000 (COND ((NULL (CAR (EVAL Z)))
46100 (COND ((NULL (CDR (EVAL Z))) NIL) (T (PUTPROP (CADR (EVAL Z)) T (QUOTE NFROM)))))
46200 (T (PUTPROP (CAAR (EVAL Z)) T (QUOTE NTO)))))
46300 EXPR)
46400
46500 (DEFPROP XPLY
46600 (LAMBDA(N Z AC)
46700 (COND ((ALIKE AC ENL) NIL)
46800 ((NULL Z) (XPLY 0 (NCONS (CAR (SUBSET ENL AC))) AC))
46900 (T
47000 (PROG2 (SETQ XMAX (COND ((GREATERP (SETQ NNN N) XMAX) N) (T XMAX)))
47100 (MAPC (FUNCTION SETN) Z)
47200 (XPLY (ADD1 N)
47300 (SUBSET (UNIQUE (UNBUCK (MAPCAR (FUNCTION GETNEAR) Z))) (APPEND AC Z))
47400 (APPEND AC Z))))))
47500 EXPR)
47600
47700 (DEFPROP ALIKE
47800 (LAMBDA(A B)
47900 (COND ((NULL A) (COND ((NULL B) T) (T NIL))) ((NULL B) NIL) (T (ALIKE (CDR A) (DELETE (CAR A) B)))))
48000 EXPR)
48100
48200 (DEFPROP SETN
48300 (LAMBDA (Z) (SET Z NNN))
48400 EXPR)
48500
48600 (DEFPROP XSET
48700 (LAMBDA (Z N) (COND ((NULL Z) NIL) (T (PROG2 (SET (CAR Z) (CONS N (CDR (EVAL (CAR Z))))) (XSET (CDR Z) N)))))
48800 EXPR)
48900
49000 (DEFPROP YSET
49100 (LAMBDA(NOD Y)
49200 (PROG (TEMP)
49300 L1 (SETQ TEMP (CONS (EVAL NOD) Y))
49400 (COND ((OAOOP TEMP ENL) (GO L2)))
49500 (SETQ TEMP (CONS (EVAL NOD) (SUB1 Y)))
49600 (COND ((OAOOP TEMP ENL) (GO L2)))
49700 (SETQ TEMP (CONS (EVAL NOD) (ADD1 Y)))
49800 (COND ((OAOOP TEMP ENL) (GO L2)))
49900 (MOVE ENL Y)
50000 (GO L1)
50100 L2 (SET NOD TEMP)
50200 (YSET2 (GETNEAR NOD) NOD)
50300 (RETURN NIL)))
50400 EXPR)
50500
50600 (DEFPROP YSET2
50700 (LAMBDA(Z NOD)
50800 (COND ((NULL Z) NIL)
50900 (T
51000 (PROG (TEM)
51100 (COND ((NOT (NUMBERP (SETQ TEM (EVAL (CAR Z))))) (GO LL)))
51200 (COND
51300 ((EQUAL TEM (CAR (EVAL NOD)))
51400 (COND
51500 ((AND (NOT (OAOOP (CONS TEM (SUB1 (CDR (EVAL NOD)))) ENL))
51600 (OAOOP (CONS TEM (ADD1 (CDR (EVAL NOD)))) ENL))
51700 (YSET (CAR Z) (ADD1 (CDR (EVAL NOD)))))
51800 (T (YSET (CAR Z) (SUB1 (CDR (EVAL NOD)))))))
51900 (T (YSET (CAR Z) (CDR (EVAL NOD)))))
52000 LL (YSET2 (CDR Z) NOD)
52100 (RETURN NIL)))))
52200 EXPR)
52300
52400 (DEFPROP OAOOP
52500 (LAMBDA (N Z) (COND ((NULL Z) T) ((EQUAL N (EVAL (CAR Z))) NIL) (T (OAOOP N (CDR Z)))))
52600 EXPR)
52700
52800 (DEFPROP MOVE
52900 (LAMBDA(Z Y)
53000 (COND ((NULL Z) NIL)
53100 (T
53200 (PROG2 (COND ((ATOM (EVAL (CAR Z))) NIL)
53300 ((GREATERP Y (CDR (EVAL (CAR Z)))) NIL)
53400 (T (SET (CAR Z) (CONS (CAR (EVAL (CAR Z))) (ADD1 (CDR (EVAL (CAR Z))))))))
53500 (MOVE (CDR Z) Y)))))
53600 EXPR)
53700
53800 (DEFPROP YMINAX
53900 (LAMBDA(Z)
54000 (COND ((NULL Z) NIL)
54100 (T
54200 (PROG (Y)
54300 (SETQ Y (CDR (EVAL (CAR Z))))
54400 (COND ((GREATERP Y YMAX) (SETQ YMAX Y)))
54500 (COND ((LESSP Y YMIN) (SETQ YMIN Y)))
54600 (YMINAX (CDR Z))))))
54700 EXPR)
54800
54900 (DEFPROP YMISS
55000 (LAMBDA(Z)
55100 (COND ((NULL Z) NIL) ((NUMBERP (EVAL (CAR Z))) (CONS (CAR Z) (YMISS (CDR Z)))) (T (YMISS (CDR Z)))))
55200 EXPR)
55300
55400 (DEFPROP LSP
55500 (LAMBDA(Z)
55600 (COND ((ATOM (CAR Z))
55700 (PROG (TEM Y TPEN)
55800 (SETQ TEM ORG)
55900 (SETQ Y (COND ((SETQ TPEN (ATOM (CDR Z))) (CDR Z)) (T (CADR Z))))
56000 (SETQ ORG (CONS (PLUS (TIMES SIZ (CAR Z)) (CAR ORG)) (PLUS (TIMES SIZ Y) (CDR ORG))))
56100 (OUTC T NIL)
56200 (COND ((NOT (EQ PEN TPEN)) (COND ((SETQ PEN TPEN) (DIT 17 20)) (T (DIT 20 40)))))
56300 (MIDIT (TIMES SIZ (CAR Z)) (TIMES SIZ Y))
56400 (OUTC NIL NIL)
56500 (RETURN ORG)))
56600 (T (PROG2 (LSP (LIST (CAAR Z) (CDAR Z))) (LSP (CDR Z))))))
56700 EXPR)
56800
56900 (DEFPROP MIDIT
57000 (LAMBDA(X Y)
57100 (COND ((ZEROP X) (DIT (ABS Y) (COND ((MINUSP Y) 10) (T 4))))
57200 ((ZEROP Y) (DIT (ABS X) (COND ((MINUSP X) 2) (T 1))))
57300 ((EQ (ABS X) (ABS Y))
57400 (DIT (ABS X) (PLUS 100 (COND ((MINUSP X) 2) (T 1)) (COND ((MINUSP Y) 10) (T 4)))))
57500 (T
57600 (PROG2 (MIDIT (QUOTIENT X 2) (QUOTIENT Y 2))
57700 (MIDIT (DIFFERENCE X (QUOTIENT X 2)) (DIFFERENCE Y (QUOTIENT Y 2)))))))
57800 EXPR)
57900
58000 (DEFPROP DIT
58100 (LAMBDA (N X) (PROG NIL L (COND ((ZEROP N) (RETURN NIL))) (TYO X) (SETQ N (SUB1 N)) (GO L)))
58200 EXPR)
58300
58400 (DEFPROP SOF
58500 (LAMBDA NIL (PROG2 (OUTPUT PTP:) (OUTC T T) (LINELENGTH 377777) (OUTC NIL NIL)))
58600 EXPR)
58700
58800 (DEFPROP EOF
58900 (LAMBDA NIL (OUTC NIL T))
59000 EXPR)
59100
59200 (DEFPROP POT
59300 (LAMBDA(Z)
59400 (COND ((NULL Z) (PROG2 (OUTC T NIL) (DIT 100 100) (EOF) NIL)) (T (PROG2 (LSP (CAR Z)) (POT (CDR Z))))))
59500 EXPR)
59600
59700 (DEFPROP YMAX
59800 (NIL . 0)
59900 VALUE)
60000
60100 (DEFPROP XMAX
60200 (NIL . 3)
60300 VALUE)
60400
60500 (DEFPROP YMIN
60600 (NIL . -1)
60700 VALUE)
60800
60900 (DEFPROP F1
61000 (NIL ((P1 P2 P3) P4 P5 P6) ((P7 P8 P9) P10 P11 P12))
61100 VALUE)
61200
61300 (DEFPROP F2
61400 (NIL ((P1 P4) K1 K2 P2) ((K1 P3) P4 P5) ((K2 P2) P3 P6))
61500 VALUE)
61600
61700 (DEFPROP NK
61800 (NIL (0 . 12) (10 0) (-10 . -5) (10 . -5) (2 0))
61900 VALUE)
62000
62100 (DEFPROP NP
62200 (NIL (0 . 12) (6 . 0) (2 . -2) (0 . -1) (-2 . -2) (-6 . 0) (12 -5))
62300 VALUE)
62400
62500 (DEFPROP NODE
62600 (NIL (2 4) (2 . -2) (0 . -4) (-2 . -2) (-4 . 0) (-2 . 2) (0 . 4) (2 . 2) (4 . 0) (-2 -4))
62700 VALUE)
62800
62900 (DEFPROP N0
63000 (NIL (3 0) (2 . 0) (3 . 3) (0 . 4) (-3 . 3) (-2 . 0) (-3 . -3) (0 . -4) (3 . -3) (7 0))
63100 VALUE)
63200
63300 (DEFPROP N1
63400 (NIL (1 7) (3 . 3) (0 . -12) (-3 0) (6 . 0) (3 0))
63500 VALUE)
63600
63700 (DEFPROP N2
63800 (NIL (0 10) (2 . 2) (3 . 0) (3 . -3) (0 . -2) (-1 . -1) (-5 . 0) (-2 . -2) (0 . -2) (10 . 0) (2 0))
63900 VALUE)
64000
64100 (DEFPROP N3
64200 (NIL (6 . 0) (2 . 2) (0 . 2) (-1 . 1) (-3 . 0) (3 0) (1 . 1) (0 . 2) (-2 . 2) (-6 . 0) (12 -12))
64300 VALUE)
64400
64500 (DEFPROP N4
64600 (NIL (4 12) (-4 . -6) (10 . 0) (-2 6) (0 . -12) (4 0))
64700 VALUE)
64800
64900 (DEFPROP N5
65000 (NIL (6 . 0) (2 . 2) (0 . 2) (-2 . 2) (-6 . 0) (0 . 4) (10 . 0) (2 -12))
65100 VALUE)
65200
65300 (DEFPROP N6
65400 (NIL (0 4) (2 . 2) (4 . 0) (2 . -2) (0 . -2) (-2 . -2) (-4 . 0) (-2 . 2) (0 . 5) (3 . 3) (5 . 0) (2 -12))
65500 VALUE)
65600
65700 (DEFPROP N7
65800 (NIL (10 . 12) (-10 . 0) (0 . -2) (12 -10))
65900 VALUE)
66000
66100 (DEFPROP N8
66200 (NIL (1 5)
66300 (-1 . 1)
66400 (0 . 2)
66500 (2 . 2)
66600 (4 . 0)
66700 (2 . -2)
66800 (0 . -2)
66900 (-1 . -1)
67000 (-6 . 0)
67100 (-1 . -1)
67200 (0 . -2)
67300 (2 . -2)
67400 (4 . 0)
67500 (2 . 2)
67600 (0 . 2)
67700 (-1 . 1)
67800 (3 -5))
67900 VALUE)
68000
68100 (DEFPROP N9
68200 (NIL (5 . 0) (3 . 3) (0 . 5) (-2 . 2) (-4 . 0) (-2 . -2) (0 . -2) (2 . -2) (4 . 0) (2 . 2) (2 -6))
68300 VALUE)
68400
68500 (DEFPROP VADD
68600 (LAMBDA (P1 P2) (CONS (PLUS (CAR P1) (CAR P2)) (PLUS (CDR P2) (CDR P1))))
68700 EXPR)
68800
68900 (DEFPROP VSUB
69000 (LAMBDA (P2 P3) (CONS (DIFFERENCE (CAR P2) (CAR P3)) (DIFFERENCE (CDR P2) (CDR P3))))
69100 EXPR)
69200
69300 (DEFPROP VSUBSIZ
69400 (LAMBDA (A B) (CONS (QUOTIENT (DIFFERENCE (CAR A) (CAR B)) SIZ) (QUOTIENT (DIFFERENCE (CDR A) (CDR B)) SIZ)))
69500 EXPR)
69600
69700 (DEFPROP LXY
69800 (LAMBDA (Z) (CONS (CAR Z) (NCONS (CDR Z))))
69900 EXPR)
70000
70100 (DEFPROP SLOPE
70200 (LAMBDA (P1 P2) (QUOTIENT (DIFFERENCE (CDR P2) (CDR P1) P 0.0) (DIFFERENCE (CAR P2) (CAR P1))))
70300 EXPR)
70400
70500 (DEFPROP MIDPOINT
70600 (LAMBDA (Z1 Z2) (CONS (QUOTIENT (PLUS (CAR Z1) (CAR Z2)) 2) (QUOTIENT (PLUS (CDR Z1) (CDR Z2)) 2)))
70700 EXPR)
70800
70900 (DEFPROP METRIC
71000 (LAMBDA (P1 P2) (PLUS (SQUARE (DIFFERENCE (CAR P1) (CAR P2))) (SQUARE (DIFFERENCE (CDR P1) (CDR P2)))))
71100 EXPR)
71200
71300 (DEFPROP SQUARE
71400 (LAMBDA (N) (TIMES N N))
71500 EXPR)
71600
71700 (DEFPROP INCREM
71800 (LAMBDA(P D)
71900 (PROG (TEM)
72000 (RETURN
72100 (CONS (SETQ TEM (PLUS (CAR P) (ALSH (CDR P) (MINUS D)))) (DIFFERENCE (CDR P) (ALSH TEM (MINUS D)))))))
72200 EXPR)
72300
72400 (DEFPROP CARLAST
72500 (LAMBDA (Z) (CAR (LAST Z)))
72600 EXPR)
72700
72800 (DEFPROP ALSH
72900 (LAMBDA (Z N) (COND ((MINUSP Z) (MINUS (LSH (ABS Z) N))) (T (LSH Z N))))
73000 EXPR)
73100
73200 (DEFPROP ADJUST
73300 (LAMBDA (Z) (SET Z (CONS (TIMES (CAR (EVAL Z)) 300) (TIMES (CDR (EVAL Z)) 300))))
73400 EXPR)
73500
73600 (DEFPROP ROTATE
73700 (LAMBDA(P SIN COS)
73800 (CONS (FIX (DIFFERENCE (TIMES COS (PLUS 0.0 (CAR P))) (TIMES SIN (PLUS 0.0 (CDR P)))))
73900 (FIX (PLUS (TIMES COS (PLUS 0.0 (CDR P))) (TIMES SIN (PLUS 0.0 (CAR P)))))))
74000 EXPR)
74100
74200 (DEFPROP ROOT
74300 (LAMBDA (A) (NEWTON 14 (PLUS A 0.0) (QUOTIENT (PLUS A 0.0) 2.0)))
74400 EXPR)
74500
74600 (DEFPROP NEWTON
74700 (LAMBDA (N A X) (COND ((ZEROP N) X) (T (NEWTON (SUB1 N) A (QUOTIENT (PLUS X (QUOTIENT A X)) 2.0)))))
74800 EXPR)
74900
75000 (DEFPROP ZIGZAG
75100 (LAMBDA(N)
75200 (PROG (P11)
75300 (COND ((EQ PHASE 3) (SETQ PHASE 0)) (T (SETQ PHASE (ADD1 PHASE))))
75400 (SETQ L2 (PLUS L2 3))
75500 (SETQ P11 (ROTATE (CONS L2 N) SIN COS))
75600 (LS (VSUB P11 P1))
75700 (SETQ P1 P11)
75800 (RETURN (GREATERP L2 L))))
75900 EXPR)
76000
76100 (DEFPROP SQUIG
76200 (LAMBDA(P1 P2 LS)
76300 (PROG (L L2 SIN COS)
76400 (SETQ P2 (VSUB P2 P1))
76500 (SETQ P1 ACTEND)
76600 (SETQ L2 (METRIC P1 P2))
76700 (SETQ L (ROOT L2))
76800 (SETQ SIN (QUOTIENT (CDR P2) L))
76900 (SETQ COS (QUOTIENT (CAR P2) L))
77000 (SETQ L2 0)
77100 (SETQ L (FIX (DIFFERENCE L 3)))
77200 (COND ((GREATERP L2 L) (GO EXIT))
77300 ((ZEROP PHASE) (GO LOOP))
77400 ((EQ PHASE 1) (GO PH1))
77500 ((EQ PHASE 2) (GO PH2))
77600 (T (GO PH3)))
77700 LOOP (COND ((ZIGZAG 10) (GO EXIT)))
77800 PH1 (COND ((ZIGZAG 0) (GO EXIT)))
77900 PH2 (COND ((ZIGZAG -10) (GO EXIT)))
78000 PH3 (COND ((ZIGZAG 0) (GO EXIT)) (T (GO LOOP)))
78100 EXIT (SETQ ACTEND (VSUB P1 P2))
78200 (RETURN NIL)))
78300 EXPR)
78400
78500 (DEFPROP TESTS
78600 (NIL TP1 TP2 TP3 TP4 TP5 TP6 TP7 TP8 TP9 TP10 TP11 TP12 TP13 TP14 TP15 TP16 TP17 TP18 TP19 TP20 TP20 TP22)
78700 VALUE)
78800
78900 (DEFPROP TP1
79000 (NIL ((P2) P1 K1) ((P4) P3 K2) ((P6 K2 K1) P5))
79100 VALUE)
79200
79300 (DEFPROP TP2
79400 (NIL ((P2) P1 K1) ((P4 K1) P3 K2) ((P6 K2) P5))
79500 VALUE)
79600
79700 (DEFPROP TP3
79800 (NIL ((K2) P2 P1) ((P4) P3 K1) ((K1 P1) P5))
79900 VALUE)
80000
80100 (DEFPROP TP4
80200 (NIL ((K2) P2 P1) ((P4) P3 K1) ((P5 K1 P1)))
80300 VALUE)
80400
80500 (DEFPROP TP5
80600 (NIL ((K2) P2 P1) ((P1) P3 K1) ((P5 K1) P4))
80700 VALUE)
80800
80900 (DEFPROP TP6
81000 (NIL ((K2) P2 P1) ((P3 P1) K1) ((P5 K1) P4))
81100 VALUE)
81200
81300 (DEFPROP TP7
81400 (NIL ((K2 P2) P1) ((P4) P3 K1) ((P5 K1 P1)))
81500 VALUE)
81600
81700 (DEFPROP TP8
81800 (NIL ((K2 P2) P1) ((P3 P1) K1) ((P5 K1) P4))
81900 VALUE)
82000
82100 (DEFPROP TP9
82200 (NIL ((P3) P2 K1) (NIL P4 K2 P1) ((K2 P1 K1) P5))
82300 VALUE)
82400
82500 (DEFPROP TP10
82600 (NIL ((P3) P2 K1) ((K1) P4 K2 P1) ((K2 P1) P5))
82700 VALUE)
82800
82900 (DEFPROP TP11
83000 (NIL ((K2) P3 P1) (NIL P4 K1 P2) ((K1 P2 P1) P5))
83100 VALUE)
83200
83300 (DEFPROP TP12
83400 (NIL ((K2) P3 P1) (NIL P4 K1 P2) ((K1 P2 P1)))
83500 VALUE)
83600
83700 (DEFPROP TP13
83800 (NIL ((K2) P3 P1) ((P1) P4 K1 P2) ((K1 P2) P5))
83900 VALUE)
84000
84100 (DEFPROP TP14
84200 (NIL ((K2) P3 P1) ((P1) K1 P2) ((K1 P2) P4))
84300 VALUE)
84400
84500 (DEFPROP TP15
84600 (NIL ((K2 P3) P1) (NIL P4 K1 P2) ((K1 P2 P1)))
84700 VALUE)
84800
84900 (DEFPROP TP16
85000 (NIL ((K2 P3) P1) ((P1) K1 P2) ((K1 P2) P4))
85100 VALUE)
85200
85300 (DEFPROP TP17
85400 (NIL ((P4) P3 K1) (NIL P5 K2 P2 P1) ((K2 P2 P1 K1)))
85500 VALUE)
85600
85700 (DEFPROP TP18
85800 (NIL ((P4) P3 K1) ((K1) P5 K2 P2 P1) ((K2 P2 P1)))
85900 VALUE)
86000
86100 (DEFPROP TP19
86200 (NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
86300 VALUE)
86400
86500 (DEFPROP TP20
86600 (NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
86700 VALUE)
86800
86900 (DEFPROP TP20
87000 (NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
87100 VALUE)
87200
87300 (DEFPROP TP22
87400 (NIL ((K2 P4) P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
87500 VALUE)
87600
87700 (DEFPROP OFF
87800 (LAMBDA NIL (OUTC NIL T))
87900 EXPR)